home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / TSR / TPPOP18C / DICE.PAS < prev    next >
Pascal/Delphi Source File  |  1988-11-24  |  9KB  |  369 lines

  1. {$A+,B-,D+,E+,F-,I+,L+,N+,O-,R-,S-,V-}
  2. Unit Dice;
  3.  
  4. Interface
  5.  
  6. Uses Crt,
  7.      Windows;
  8.  
  9. Procedure PopDice;  { units listed in the INTERFACE are FAR }
  10.  
  11. Implementation
  12.  
  13. Type
  14.   String20 = String[20];
  15.  
  16. Var
  17.   Number  : Integer;
  18.   Adds    : Integer;
  19.   Done    : Boolean;
  20.   OldLine : String20;
  21.   OldNumber: Integer;
  22.   OldSides : Integer;
  23.   OldAdds  : Integer;
  24.   Sides   : Integer;
  25.   OldRoll : Integer;
  26.   WinX    : Integer;
  27.   WinY    : Integer;
  28.   Line    : String20;
  29.   Dee : Boolean;
  30.   Adder : Boolean;
  31.  
  32. Const
  33.     ESC = #27;
  34.     CR = #13;
  35.     BS = #8;
  36.     F1 = #59;
  37.     F2 = #60;
  38.     F3 = #61;
  39.     F4 = #62;
  40.     F5 = #63;
  41.     F6 = #64;
  42.     F7 = #65;
  43.     F8 = #66;
  44.     F9 = #67;
  45.     F10 = #68;
  46.     Ctrl_End = #117;
  47.     UpAr = #72;
  48.     DnAr = #80;
  49.     LfAr = #75;
  50.     RtAr = #77;
  51.  
  52. Function IStr(Number : Integer) : String20;
  53.  
  54. { converts an integer to a string and returns it }
  55. { as a function result, which is more convient.  }
  56.  
  57. Var
  58.   Temp : String20;
  59.  
  60. Begin
  61.   Str(Number,Temp);
  62.   IStr := Temp;
  63. End;
  64.  
  65. Procedure BreakUp(Line : String20;Var Number,Sides,Adds : Integer);
  66.  
  67. { splits the string containing the dice roll into three numbers:    }
  68. {  number of dice, how many sides, and modifier, i.e. 2d6+1 returns }
  69. {  2 dice of six sides with a modifer of 1.                         }
  70.  
  71. Var
  72.   Result : Integer;
  73.   TempLine : String20;
  74.   PlusMinus : Integer;
  75.   Index : Integer;
  76.  
  77. Begin
  78.   Index := Pos('d',Line);
  79.   If Index = 0 Then Index := Succ(Length(Line));
  80.   Val(Copy(Line,1,Pred(Index)),Number,Result);  { get number of sides }
  81.   Delete(Line,1,Index);                         { and remove from string }
  82.   If Line = ''            { if only dice count is given then use old }
  83.     Then Begin            { number of sides and old modifier         }
  84.       Sides := OldSides;
  85.       Adds  := OldAdds;
  86.     End
  87.   Else Begin
  88.     PlusMinus := Pos('+',Line);                        { look for modifier    }
  89.     If PlusMinus = 0 Then PlusMinus := Pos('-',Line);  { it could be negative }
  90.     If PlusMinus = 0
  91.       Then Begin
  92.         TempLine := Line;
  93.         Line := '';
  94.       End
  95.     Else Begin
  96.       TempLine := Copy(Line,1,Pred(PlusMinus));   { get number of sides    }
  97.       Delete(Line,1,Pred(PlusMinus));             { and remove from string }
  98.     End;
  99.     If TempLine = ''
  100.       Then Sides := OldSides
  101.     Else Val(TempLine,Sides,Result);             { sides now as integer }
  102.     If Sides = 0 Then Sides := OldSides;         { use old if zero }
  103.     If Line[1] = '+' Then Delete(Line,1,1);
  104.     Adds := 0;
  105.     If Line <> '' Then
  106.     Begin
  107.       Val(Line,Adds,Result);                     { get modifier }
  108.       If Result <> 0 Then Val(Copy(Line,1,Pred(Result)),Adds,Result);
  109.     End;
  110.   End;
  111.   OldNumber := Number;                   { make old values equal new values }
  112.   OldSides  := Sides;
  113.   OldAdds   := Adds;
  114. End;
  115.  
  116. Procedure Show(Line : String20);
  117.  
  118. { given a string with a dice roll, breaks it up and displays it }
  119.  
  120. Begin
  121.   GotoXY(2,3);
  122.   ClrEol;
  123.   BreakUp(Line,Number,Sides,Adds);
  124.   Write(Number,'d',Sides);
  125.   If Adds > 0 Then Write('+');
  126.   If Adds <> 0 Then Write(Adds);
  127.   Write(' = ');
  128. End;
  129.  
  130. Procedure ShowOld;
  131.  
  132. { displays the old dice roll }
  133.  
  134. Begin
  135.   If OldRoll <> 0 Then
  136.   Begin
  137.     Show(OldLine);
  138.     Write(OldRoll);
  139.   End;
  140. End;
  141.  
  142. Function Roll(Number,Sides,Adds : Integer) : Integer;
  143.  
  144. { rolls the dice and adds the modifier }
  145.  
  146. Var
  147.   Counter : Integer;
  148.  
  149. Begin
  150.   For Counter := 1 to Number do Adds := Succ(Adds+Random(Sides));
  151.   Roll := Adds;
  152. End;
  153.  
  154. Procedure MkLine(Var Line : String20;Sides : Integer);
  155.  
  156. { fixes the dice roll string in case of any oddities }
  157.  
  158. Var
  159.  Position : Integer;
  160.  
  161. Begin
  162.   If Line = ''                            { if no count the use 1d }
  163.     Then Line := Concat('1d',IStr(Sides))
  164.   Else Begin
  165.     Position := Pos('d',Line);
  166.     If Position <> 0
  167.       Then Line := Copy(Line,1,Pred(Position))
  168.     Else Begin
  169.       Position := Pos('+',Line);
  170.       If Position = 0 Then Position := Pos('-',Line);
  171.       If Position <> 0 Then Line := Copy(Line,1,Pred(Position));
  172.     End;
  173.     Line := Line + 'd';
  174.     Line := Concat(Line,IStr(Sides));
  175.   End;
  176. End;
  177.  
  178. Procedure FunctionKey(Var KeyCode : Char);
  179.  
  180. { processes the function keys, F01 - F10 }
  181.  
  182. Var
  183.   K : Char;
  184.  
  185. Begin
  186.   K := ReadKey;
  187.   KeyCode := CR;
  188.   Case K of
  189.     F1  : MkLine(Line,100);
  190.     F2  : MkLine(Line,20);
  191.     F3  : MkLine(Line,12);
  192.     F4  : MkLine(Line,4);
  193.     F6  : MkLine(Line,6);
  194.     F8  : MkLine(Line,8);
  195.     F10 : MkLine(Line,10);
  196.     Else KeyCode := #0;
  197.   End;
  198. End;
  199.  
  200. Procedure NumberKey(Var Line : String20;Var KeyCode : Char);
  201.  
  202. { processes a numeric keystroke }
  203.  
  204. Begin
  205.   If Length(Line) < 13           { 13 digits is the absolute limit }
  206.     Then Line := Line + KeyCode
  207.   Else KeyCode := #0;            { trash the key if string is full }
  208. End;
  209.  
  210. Procedure AdderKey(Var Line : String20;Var KeyCode : Char);
  211.  
  212. { process the + or - key for any dice modifiers }
  213.  
  214. Var
  215.   Position : Integer;
  216.  
  217. Begin
  218.   If (Not Adder)
  219.     Then Begin
  220.       If Line = ''              { if blank string the use old number and sides }
  221.         Then Begin
  222.           Str(OldNumber,Line);
  223.           Line := Line + 'd';
  224.           Line := Concat(Line,IStr(OldSides));
  225.           Write(Line);
  226.         End
  227.       Else If Not Dee Then      { if the 'd' character hasn't been pressed }
  228.       Begin
  229.         Line := Line + 'd';
  230.         Dee := True;
  231.         Write('d');
  232.       End;
  233.       If Pos('d',Line) = Length(Line) Then  { if no sides the use old sides }
  234.       Begin
  235.         Line := Concat(Line,IStr(OldSides));
  236.         Write(OldSides);
  237.       End;
  238.       Adder := True;
  239.       Line := Line + KeyCode;
  240.     end
  241.   Else KeyCode := #0;
  242. End;
  243.  
  244. Procedure DeeKey(Var Line : String20;Var KeyCode : Char);
  245.  
  246. { fix the roll string when the 'd' key is pressed }
  247.  
  248. Begin
  249.   If Not Dee
  250.     Then Begin
  251.       Dee := True;
  252.       If Line = '' Then         { if no dice count then use 1 }
  253.       Begin
  254.         Line := '1';
  255.         Write('1');
  256.       End;
  257.       Line := Line + 'd';
  258.       KeyCode := 'd';
  259.     End
  260.   Else KeyCode := #0;
  261. End;
  262.  
  263. Procedure BackSpace(Var Line : String20;Var KeyCode : Char);
  264.  
  265. { process destructive backspace }
  266.  
  267. Begin
  268.   If Line <> ''  { do nothing if blank line }
  269.     Then Begin
  270.       If Line[Length(Line)] = 'd' Then Dee := False;  { remove 'd' }
  271.       If Line[Length(Line)] In['-','+'] Then Adder := False;  { remove + or - }
  272.       Delete(Line,Length(Line),1);   { remove last character }
  273.       Write(BS,' ');               { backspace and space - backup again later }
  274.     End
  275.   Else KeyCode := #0;
  276. End;
  277.  
  278. Procedure CarriageExit(Var Line : String20);
  279.  
  280. { Carriage Return processing }
  281.  
  282. Begin
  283.   If Line = '' Then            { if blank line then use old dice roll }
  284.   Begin
  285.     Str(OldNumber,Line);
  286.     Line := Line + 'd';
  287.     Line := Concat(Line,IStr(OldSides));
  288.     If OldAdds <> 0 Then
  289.     Begin
  290.       If OldAdds > 0 Then Line := Line + '+';
  291.       Line := Concat(Line,IStr(OldAdds));
  292.     End;
  293.   End;
  294. End;
  295.  
  296. Procedure GetLine(Var Line : String20);
  297.  
  298. { accepts a dice roll from the keyboard, will not allow illegal keystrokes }
  299. Var
  300.   KeyCode : Char;
  301.  
  302. Begin
  303.   Dee := False;
  304.   Adder := False;
  305.   Repeat
  306.     KeyCode := ReadKey;
  307.     Case KeyCode of
  308.       #0       : FunctionKey(KeyCode);
  309.       Esc      : Done := True;             { exit the popup program }
  310.       '0'..'9' : NumberKey(Line,KeyCode);  { digit key }
  311.       #43,
  312.       #45      : AdderKey(Line,KeyCode);   { + or - }
  313.       #32,
  314.       #68,
  315.       #100     : DeeKey(Line,KeyCode);     { 'd', 'D' or space }
  316.       BS       : BackSpace(Line,KeyCode);  { backspace }
  317.       CR       : CarriageExit(Line);       { carriage return }
  318.       Else KeyCode := #0;                  { trash illegal keys }
  319.     End;
  320.  
  321.     If (KeyCode <> CR) And (KeyCode <> #0) Then Write(KeyCode);
  322.   Until Done or (KeyCode = CR);
  323. End;
  324.  
  325. Procedure PopDice;
  326.  
  327. { saves the underlying screen, displays the menu, and accepts entry }
  328.  
  329. Begin
  330.   Done := False;
  331.   MakeWindow(31,1,59,6,White,Magenta,Single);   { save screen and make window }
  332.   WriteLn(' F1   d100     F6   d6');          { display menu }
  333.   WriteLn(' F2   d20      F8   d8');
  334.   WriteLn(' F3   d12      F10  d10');
  335.   Write  (' F4   d4       CR   Repeat');
  336.   Drawbox(WinX,WinY,WinX+24,WinY+4,White,Black,Double);  { draw data box }
  337.   DrawHorizontalLine(WinX,WinY+2,25,DoubleSide);
  338.   ShowOld;                                       { show the previous roll }
  339.   Repeat
  340.     GotoXY(2,1);
  341.     ClrEol;
  342.     Write('Roll: ',Line);
  343.     GetLine(Line);
  344.     If (Not Done) And (Line <> '') Then
  345.     Begin
  346.       Show(Line);
  347.       OldRoll := Roll(Number,Sides,Adds);
  348.       Write(OldRoll);
  349.       If Line <> '' Then OldLine := Line;
  350.       Line := '';
  351.     End;
  352.   Until Done;
  353.   RemoveWindow;                         { restore original screen }
  354. End;
  355.  
  356. Begin   { initialization code }
  357.   DirectVideo := False;             { lets be safe          }
  358.   OldLine  := '';                   { set up default values }
  359.   OldNumber := 1;
  360.   OldSides := 20;
  361.   OldAdds  := 0;
  362.   Sides    := 100;
  363.   OldRoll  := 0;
  364.   WinX     := 1;
  365.   WinY     := 1;
  366.   Line     := '';
  367.   Randomize;
  368. End.
  369.